home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 December / 2004-12 CHIP.iso / CHIP / Porady / Srodowisko PHP-MySQL / ACTIVESTATE PERL ADD-ON / PERL_add-on.exe / {app} / perl / bin / instmodsh.bat < prev    next >
DOS Batch File  |  2004-08-02  |  4KB  |  159 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. :WinNT
  7. perl -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl
  12. @rem ';
  13. #!perl
  14. #line 15
  15.     eval 'exec c:\wamp\perl\\bin\perl.exe -S $0 ${1+"$@"}'
  16.     if $running_under_some_shell;
  17. #!/usr/local/bin/perl -w
  18.  
  19. use strict;
  20. use IO::File;
  21. use ExtUtils::Packlist;
  22. use ExtUtils::Installed;
  23.  
  24. use vars qw($Inst @Modules);
  25.  
  26. ################################################################################
  27.  
  28. sub do_module($)
  29. {
  30. my ($module) = @_;
  31. my $help = <<EOF;
  32. Available commands are:
  33.    f [all|prog|doc]   - List installed files of a given type
  34.    d [all|prog|doc]   - List the directories used by a module
  35.    v                  - Validate the .packlist - check for missing files
  36.    t <tarfile>        - Create a tar archive of the module
  37.    q                  - Quit the module
  38. EOF
  39. print($help);
  40. while (1)
  41.    {
  42.    print("$module cmd? ");
  43.    my $reply = <STDIN>; chomp($reply);
  44.    CASE:
  45.       {
  46.       $reply =~ /^f\s*/ and do
  47.          {
  48.          my $class = (split(' ', $reply))[1];
  49.          $class = 'all' if (! $class);
  50.          my @files;
  51.          if (eval { @files = $Inst->files($module, $class); })
  52.             {
  53.             print("$class files in $module are:\n   ",
  54.                   join("\n   ", @files), "\n");
  55.             last CASE;
  56.             }
  57.          else
  58.             { print($@); }
  59.          };
  60.       $reply =~ /^d\s*/ and do
  61.          {
  62.          my $class = (split(' ', $reply))[1];
  63.          $class = 'all' if (! $class);
  64.          my @dirs;
  65.          if (eval { @dirs = $Inst->directories($module, $class); })
  66.             {
  67.             print("$class directories in $module are:\n   ",
  68.                   join("\n   ", @dirs), "\n");
  69.             last CASE;
  70.             }
  71.          else
  72.             { print($@); }
  73.          };
  74.       $reply =~ /^t\s*/ and do
  75.          {
  76.          my $file = (split(' ', $reply))[1];
  77.          my $tmp = "/tmp/inst.$$";
  78.          if (my $fh = IO::File->new($tmp, "w"))
  79.             {
  80.             $fh->print(join("\n", $Inst->files($module)));
  81.             $fh->close();
  82.             system("tar cvf $file -I $tmp");
  83.             unlink($tmp);
  84.             last CASE;
  85.             }
  86.          else { print("Can't open $file: $!\n"); }
  87.          last CASE;
  88.          };
  89.       $reply eq 'v' and do
  90.          {
  91.          if (my @missing = $Inst->validate($module))
  92.             {
  93.             print("Files missing from $module are:\n   ",
  94.                   join("\n   ", @missing), "\n");
  95.             }
  96.          else
  97.             {
  98.             print("$module has no missing files\n");
  99.             }
  100.          last CASE;
  101.          };
  102.       $reply eq 'q' and do
  103.          {
  104.          return;
  105.          };
  106.       # Default
  107.          print($help);
  108.       }
  109.    }
  110. }
  111.  
  112. ################################################################################
  113.  
  114. sub toplevel()
  115. {
  116. my $help = <<EOF;
  117. Available commands are:
  118.    l            - List all installed modules
  119.    m <module>   - Select a module
  120.    q            - Quit the program
  121. EOF
  122. print($help);
  123. while (1)
  124.    {
  125.    print("cmd? ");
  126.    my $reply = <STDIN>; chomp($reply);
  127.    CASE:
  128.       {
  129.       $reply eq 'l' and do
  130.          {
  131.          print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
  132.          last CASE;
  133.          };
  134.       $reply =~ /^m\s+/ and do
  135.          {
  136.          do_module((split(' ', $reply))[1]);
  137.          last CASE;
  138.          };
  139.       $reply eq 'q' and do
  140.          {
  141.          exit(0);
  142.          };
  143.       # Default
  144.          print($help);
  145.       }
  146.    }
  147. }
  148.  
  149. ################################################################################
  150.  
  151. $Inst = ExtUtils::Installed->new();
  152. @Modules = $Inst->modules();
  153. toplevel();
  154.  
  155. ################################################################################
  156.  
  157. __END__
  158. :endofperl
  159.